SPACE 1

home *** CD-ROM | disk | FTP | other *** search

/ SPACE 1 / SPACE - Library 1 - Volume 1.iso / program / 85 / kernel.blk < prev next >

Wrap

Text File | 1986-07-13 | 96KB | 1 lines

\ The Rest is Silence 20Jun86gem************************************************************* ************************************************************* *** *** *** Please direct all questions, comments, and *** *** miscellaneous personal abuse to: *** *** *** *** Henry Laxen or Michael Perry *** *** 1259 Cornell Avenue 1125 Bancroft Way *** *** Berkeley, California Berkeley, California *** *** 94706 94702 *** *** *** *** modified for Atari ST by: George Morison *** *** 70745,1411 CompuServe *** ************************************************************* ************************************************************* \ Target System Setup 02Jul86gemONLY FORTH META ALSO FORTH 6 CONSTANT bank HEX A800 ' TARGET-ORIGIN >BODY ! IN-META DECIMAL 2 92 THRU ( System Source Screens ) HEX CR .( Unresolved references: ) CR .UNRESOLVED CR .( Statistics: ) CR .( Last Host Address: ) [FORTH] HERE U. CR .( First Target Code Address: ) META 500 THERE U. CR .( Last Target Code Address: ) META HERE-T THERE U. CR CR DOS HERE-T 500 3E - 4 + !-T HERE-T 500 1A - !-T META 500 3E - THERE HERE-T 100 + ONLY FORTH ALSO DOS SAVE A:KERNEL.TOS FORTH CR .( Now run KERNEL.TOS and type: ) CR .( EXTEND OK <CR> ) DECIMAL \ Declare the Forward References and Version # 26Jun86gem: ]] ] ; : [[ [COMPILE] [ ; FORTH IMMEDIATE META FORWARD: DEFINITIONS FORWARD: [ LABEL FILE-HEADER HEX 500 3E - DP-T ! 601A ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 0 ,-T 500 ,-T -1 ,-T LABEL LOADER -02 PCD) A1 LEA LONG FFFF. # D0 MOVE WORD 22 # D0 ADD 500 22 - bank L#) A0 LEA BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 )+ A0 )+ MOVE REPEAT 500 bank L#) JMP DECIMAL \ Boot up Vectors and NEXT Interpreter 26Jun86gemASSEMBLER LABEL ORIGIN -1 bank L#) JMP ( Low Level COLD Entry point ) -1 bank L#) JMP ( Low Level WARM Entry point ) LABEL >NEXT IP )+ D7 MOVE D7 W LMOVE W )+ D7 MOVE D7 A0 LMOVE A0 ) JMP ASSEMBLER >NEXT META CONSTANT >NEXT ASSEMBLER DEFINITIONS META H: NEXT META ASSEMBLER >NEXT bank L#) JMP ; IN-META HERE-T DUP 100 + CURRENT-T ! ( harmless ) VOCABULARY FORTH FORTH DEFINITIONS 0 OVER 2+ !-T ( link ) DUP 2+ SWAP 16 + !-T ( thread ) IN-META \ Run Time Code for Defining Words 06Jan86gemASSEMBLER LABEL NEST IP RP -) MOVE W IP LMOVE NEXT CODE EXIT (S -- ) RP )+ D7 MOVE D7 IP LMOVE NEXT END-CODE CODE UNNEST ' EXIT @-T ' UNNEST !-T END-CODE ASSEMBLER LABEL DODOES IP RP -) MOVE A7 )+ IP LMOVE ( fall through to DOCREATE ) LABEL DOCREATE W SP -) MOVE NEXT \ Run Time Code for Defining Words 26Jun86gemVARIABLE UP LABEL DOCONSTANT W ) SP -) MOVE NEXT LABEL DOUSER-VARIABLE W ) D0 MOVE UP bank L#) D0 ADD D0 SP -) MOVE NEXT CODE (LIT) (S -- n ) IP )+ SP -) MOVE NEXT END-CODE \ Meta Defining Words 06Jan86gemT: LITERAL (S n -- ) [TARGET] (LIT) ,-T T; T: DLITERAL (S d -- ) [TARGET] (LIT) ,-T [TARGET] (LIT) ,-T T; T: ASCII (S -- ) [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META] T; T: ['] (S -- ) 'T >BODY @ [[ TRANSITION ]] LITERAL [META] T; : CONSTANT (S n -- ) RECREATE [[ ASSEMBLER DOCONSTANT ]] LITERAL ,-T DUP ,-T CONSTANT ; \ Identify numbers and forward References 19Jun86gemHEX FORWARD: <(;CODE)> T: DOES> (S -- ) [FORWARD] <(;CODE)> HERE-T 4EB9 ,-T 6 ,-T [[ ASSEMBLER DODOES ]] LITERAL ,-T T; : NUMERIC (S -- ) [FORTH] HERE [META] NUMBER DPL @ 1+ IF [[ TRANSITION ]] DLITERAL [META] ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ; : UNDEFINED (S -- ) HERE-T 0 ,-T IN-FORWARD [FORTH] CREATE [META] TRANSITION [FORTH] , FALSE , [META] DOES> FORWARD-CODE ; DECIMAL \ Meta Compiler Compiling Loop 06Jan86gem[FORTH] VARIABLE T-IN META : ] (S -- ) STATE-T ON IN-TRANSITION BEGIN >IN @ T-IN ! DEFINED IF EXECUTE ELSE COUNT NUMERIC? IF NUMERIC ELSE T-IN @ >IN ! UNDEFINED THEN THEN STATE-T @ 0= UNTIL ; T: [ (S -- ) IN-META STATE-T OFF T; T: ; (S -- ) [TARGET] UNNEST [[ TRANSITION ]] [ T; : : (S -- ) TARGET-CREATE [[ ASSEMBLER NEST ]] LITERAL ,-T ] ; \ Run Time Code for Control Structures 06Jan86gemCODE BRANCH (S -- ) LABEL BRAN1 IP ) D7 MOVE D7 IP LMOVE NEXT END-CODE CODE ?BRANCH (S f -- ) SP )+ TST BRAN1 BEQ IP )+ TST NEXT END-CODE \ Meta Compiler Branching Words 06Jan86gemT: BEGIN ?<MARK T; T: AGAIN [TARGET] BRANCH ?<RESOLVE T; T: UNTIL [TARGET] ?BRANCH ?<RESOLVE T; T: IF [TARGET] ?BRANCH ?>MARK T; T: THEN ?>RESOLVE T; T: ELSE [TARGET] BRANCH ?>MARK 2SWAP ?>RESOLVE T; T: WHILE [[ TRANSITION ]] IF T; T: REPEAT 2SWAP [[ TRANSITION ]] AGAIN THEN T; \ Run Time Code for Control Structures 06Jan86gem CODE (LOOP) (S -- ) 1 RP ) ADDQ BRAN1 BVC LONG RP )+ TST WORD RP )+ TST IP )+ TST NEXT END-CODE CODE (+LOOP) (S n -- ) SP )+ D0 MOVE D0 RP ) ADD BRAN1 BVC LONG RP )+ TST WORD RP )+ TST IP )+ TST NEXT END-CODE \ Run Time Code for Control Structures 19Jun86gemHEX CODE (DO) (S l i -- ) SP )+ D0 MOVE SP )+ D1 MOVE LABEL PDO IP )+ RP -) MOVE 8000 # D1 ADD D1 RP -) MOVE D1 D0 SUB D0 RP -) MOVE NEXT END-CODE CODE (?DO) (S l i -- ) SP )+ D0 MOVE SP )+ D1 MOVE D0 D1 CMP PDO BNE IP ) D7 MOVE D7 IP LMOVE NEXT END-CODE : BOUNDS (S adr len -- lim first ) OVER + SWAP ; DECIMAL \ Meta compiler Branching & Looping 06Jan86gemT: ?DO [TARGET] (?DO) ?>MARK T; T: DO [TARGET] (DO) ?>MARK T; T: LOOP [TARGET] (LOOP) OVER 2+ OVER ?<RESOLVE ?>RESOLVE T; T: +LOOP [TARGET] (+LOOP) OVER 2+ OVER ?<RESOLVE ?>RESOLVE T; \ Execution Control 26Jun86gemASSEMBLER >NEXT META CONSTANT >NEXT CODE EXECUTE (S cfa -- ) SP )+ D7 MOVE D7 W LMOVE W )+ D7 MOVE D7 A0 LMOVE A0 ) JMP END-CODE CODE PERFORM (S addr-of-cfa -- ) SP )+ D7 MOVE D7 W LMOVE W )+ D7 MOVE D7 W LMOVE W )+ D7 MOVE D7 A0 LMOVE A0 ) JMP END-CODE LABEL DODEFER (S -- ) ' PERFORM @-T 4 + bank L#) JMP LABEL DOUSER-DEFER W ) D7 MOVE UP bank L#) D7 ADD ' PERFORM @-T 2+ bank L#) JMP CODE GO (S addr -- ) RTS END-CODE CODE NOOP NEXT END-CODE CODE PAUSE NEXT END-CODE \ Execution Control 06Jan86gemCODE I (S -- n ) RP ) D0 MOVE 2 RP D) D0 ADD D0 SP -) MOVE NEXT END-CODE CODE J (S -- n ) 6 RP D) D0 MOVE 8 RP D) D0 ADD D0 SP -) MOVE NEXT END-CODE CODE (LEAVE) (S -- ) LABEL PLEAVE LONG RP )+ TST WORD RP )+ D7 MOVE D7 IP LMOVE NEXT END-CODE CODE (?LEAVE) (S f -- ) SP )+ TST PLEAVE BNE NEXT END-CODE T: LEAVE [TARGET] (LEAVE) T; T: ?LEAVE [TARGET] (?LEAVE) T; \ 16 and 8 bit Memory Operations 06Jan86gemCODE @ (S addr -- n ) SP ) D7 MOVE D7 A0 LMOVE BYTE A0 )+ D0 MOVE WORD 8 # D0 LSL BYTE A0 ) D0 MOVE WORD D0 SP ) MOVE NEXT END-CODE CODE ! (S n addr -- ) SP )+ D7 MOVE D7 A0 LMOVE SP )+ D0 MOVE BYTE D0 1 A0 D) MOVE WORD 8 # D0 LSR BYTE D0 A0 ) MOVE NEXT END-CODE CODE C@ (S addr -- char ) SP ) D7 MOVE D7 A0 LMOVE D0 CLR BYTE A0 ) D0 MOVE WORD D0 SP ) MOVE NEXT END-CODE CODE C! (S char addr -- ) SP )+ D7 MOVE D7 A0 LMOVE SP )+ D0 MOVE BYTE D0 A0 ) MOVE NEXT END-CODE \ Block Move Memory Operations 06Jan86gemCODE CMOVE (S from to count -- ) SP )+ D0 MOVE 1 D0 ADDQ SP )+ D7 MOVE D7 A0 LMOVE SP )+ D7 MOVE D7 A1 LMOVE BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 )+ A0 )+ MOVE REPEAT NEXT END-CODE CODE CMOVE> (S from to count -- ) SP )+ D0 MOVE SP )+ D7 MOVE D0 D7 ADD D7 A0 LMOVE SP )+ D7 MOVE D0 D7 ADD D7 A1 LMOVE 1 D0 ADDQ BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 -) A0 -) MOVE REPEAT NEXT END-CODE \ 16 bit Stack Operations 06Jan86gemCODE SP@ (S -- n ) SP SP -) MOVE NEXT END-CODE CODE SP! (S n -- ) SP )+ D7 MOVE D7 SP LMOVE NEXT END-CODE CODE RP@ (S -- addr ) RP SP -) MOVE NEXT END-CODE CODE RP! (S n -- ) SP )+ D7 MOVE D7 RP LMOVE NEXT END-CODE \ 16 bit Stack Operations 06Jan86gemCODE DROP (S n1 -- ) SP )+ D0 MOVE NEXT END-CODE CODE DUP (S n1 -- n1 n1 ) SP ) SP -) MOVE NEXT END-CODE CODE SWAP (S n1 n2 -- n2 n1 ) LONG SP ) D0 MOVE D0 SWAP D0 SP ) MOVE NEXT END-CODE CODE OVER (S n1 n2 -- n1 n2 n1 ) 2 SP D) SP -) MOVE NEXT END-CODE \ 16 bit Stack Operations 06Jan86gemCODE TUCK (S n1 n2 -- n2 n1 n2 ) LONG SP ) D0 MOVE D0 SWAP D0 SP ) MOVE WORD D0 SP -) MOVE NEXT END-CODE CODE NIP (S n1 n2 -- n2 ) SP )+ SP ) MOVE NEXT END-CODE CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) SP )+ D1 MOVE SP )+ D2 MOVE SP ) D0 MOVE D2 SP ) MOVE D1 SP -) MOVE D0 SP -) MOVE NEXT END-CODE CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) SP )+ D2 MOVE SP )+ D0 MOVE SP ) D1 MOVE D2 SP ) MOVE D1 SP -) MOVE D0 SP -) MOVE NEXT END-CODE CODE FLIP (S n1 -- n2 ) ( byte swap ) SP )+ D0 MOVE 8 # D0 ROL D0 SP -) MOVE NEXT END-CODE : ?DUP (S n -- [n] n ) DUP IF DUP THEN ; \ 16 bit Stack Operations 06Jan86gemCODE R> (S -- n ) RP )+ SP -) MOVE NEXT END-CODE CODE >R (S n -- ) SP )+ RP -) MOVE NEXT END-CODE CODE R@ RP ) SP -) MOVE NEXT END-CODE CODE PICK (S nm ... n2 n1 k -- nm ... n2 n1 nk ) LONG D0 CLR WORD SP )+ D0 MOVE D0 D0 ADD 0 D0 SP DI) SP -) MOVE NEXT END-CODE : ROLL (S n1 n2 .. nk n -- wierd ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \ 16 bit Logical Operations * 01Jul86gemCODE AND (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) AND NEXT END-CODE CODE OR (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) OR NEXT END-CODE CODE XOR (S n1 n2 -- n3 ) SP )+ D0 MOVE D0 SP ) EOR NEXT END-CODE CODE NOT (S n -- n' ) SP ) NOT NEXT END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE 6 CONSTANT BANK \ high word of where Forth will reside. \ important! \ 16 bit Logical Operations 06Jan86gemCODE CSET (S b addr -- ) SP )+ D7 MOVE D7 A0 LMOVE SP )+ D0 MOVE BYTE D0 A0 ) OR NEXT END-CODE CODE CRESET (S b addr -- ) SP )+ D7 MOVE D7 A0 LMOVE SP )+ D0 MOVE D0 NOT BYTE D0 A0 ) AND NEXT END-CODE CODE CTOGGLE (S b addr -- ) SP )+ D7 MOVE D7 A0 LMOVE SP )+ D0 MOVE BYTE D0 A0 ) EOR NEXT END-CODE CODE ON (S addr -- ) SP )+ D7 MOVE D7 A0 LMOVE TRUE # A0 ) MOVE NEXT END-CODE CODE OFF (S addr -- ) SP )+ D7 MOVE D7 A0 LMOVE A0 ) CLR NEXT END-CODE \ 16 bit Arithmetic Operations 06Jan86gemCODE + (S n1 n2 -- sum ) SP )+ D0 MOVE D0 SP ) ADD NEXT END-CODE CODE NEGATE (S n -- n' ) SP ) NEG NEXT END-CODE CODE - (S n1 n2 -- n1-n2 ) SP )+ D0 MOVE D0 SP ) SUB NEXT END-CODE CODE ABS (S n -- n ) SP ) TST 0< IF SP ) NEG THEN NEXT END-CODE CODE +! (S n addr -- ) SP )+ D7 MOVE D7 A0 LMOVE BYTE A0 )+ D0 MOVE WORD 8 # D0 LSL BYTE A0 ) D0 MOVE WORD SP )+ D0 ADD D0 D1 MOVE 8 # D1 LSR BYTE D0 A0 ) MOVE D1 A0 -) MOVE NEXT END-CODE 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 \ 16 bit Arithmetic Operations 06Jan86gemCODE 2* (S n -- 2*n ) SP ) ASL NEXT END-CODE CODE 2/ (S n -- n/2 ) SP ) ASR NEXT END-CODE CODE U2/ (S u -- u/2 ) SP ) LSR NEXT END-CODE CODE 8* (S n -- 8*n ) SP )+ D0 MOVE 3 # D0 ASL D0 SP -) MOVE NEXT END-CODE CODE 1+ 1 SP ) ADDQ NEXT END-CODE CODE 2+ 2 SP ) ADDQ NEXT END-CODE CODE 1- 1 SP ) SUBQ NEXT END-CODE CODE 2- 2 SP ) SUBQ NEXT END-CODE \ 16 bit Arithmetic Operations Unsigned Multiply 06Jan86gem CODE UM* (S n1 n2 -- d ) SP )+ D0 MOVE SP )+ D0 MULU LONG D0 SP -) MOVE NEXT END-CODE : U*D (S n1 n2 -- d ) UM* ; \ 16 bit Arithmetic Operations Unsigned Divide 06Jan86gemCODE UM/MOD (S d1 n1 -- Remainder Quotient ) SP )+ D0 MOVE LONG SP ) D1 MOVE D0 D1 DIVU D1 SWAP D1 SP ) MOVE NEXT END-CODE ASSEMBLER LABEL YES -1 # SP ) MOVE NEXT LABEL NO SP ) CLR NEXT \ 16 bit Comparison Operations 06Jan86gemCODE 0< (S n -- f ) SP ) TST YES BMI NO BRA END-CODE CODE 0= (S n -- f ) SP ) TST YES BEQ NO BRA END-CODE CODE 0> (S n -- f ) SP ) TST YES BGT NO BRA END-CODE CODE 0<> (S n -- f ) SP ) TST YES BNE NO BRA END-CODE CODE < (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BGT NO BRA END-CODE CODE = (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BEQ NO BRA END-CODE CODE > (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BLT NO BRA END-CODE \ 16 bit Comparison Operations 06Jan86gemCODE U< (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D0 CMP YES BHI NO BRA END-CODE CODE U> (S n1 n2 -- f ) SP )+ D0 MOVE SP ) D1 MOVE D0 D1 CMP YES BHI NO BRA END-CODE : <> (S n1 n2 -- f ) = NOT ; : ?NEGATE (S n1 n2 -- n3 ) 0< IF NEGATE THEN ; : MIN (S n1 n2 -- n3 ) 2DUP > IF SWAP THEN DROP ; : MAX (S n1 n2 -- n3 ) 2DUP < IF SWAP THEN DROP ; : BETWEEN (S n1 min max -- f ) >R OVER > SWAP R> > OR NOT ; : WITHIN (S n1 min max -- f ) 1- BETWEEN ; \ 32 bit Memory Operations 06Jan86gem: 2@ (S addr -- d ) DUP 2+ @ SWAP @ ; : 2! (S d addr -- ) TUCK ! 2+ ! ; \ 32 bit Memory and Stack Operations 06Jan86gemCODE 2DROP (S a b -- ) SP )+ D0 LMOVE NEXT END-CODE CODE 2DUP (S a b -- a b a b ) SP ) SP -) LONG MOVE NEXT END-CODE CODE 2SWAP (S a b c d -- c d a b ) LONG SP )+ D0 MOVE SP ) D1 MOVE D0 SP ) MOVE D1 SP -) MOVE NEXT END-CODE CODE 2OVER (S a b c d -- a b c d a b ) 4 SP D) SP -) LONG MOVE NEXT END-CODE : 3DUP (S a b c -- a b c a b c ) DUP 2OVER ROT ; : 4DUP (S a b c d -- a b c d a b c d ) 2OVER 2OVER ; : 2ROT (S a b c d e f --- c d e f a b ) 5 ROLL 5 ROLL ; \ 32 bit Arithmetic Operations 06Jan86gemCODE D+ (S d1 d2 -- dsum ) LONG SP )+ D0 MOVE D0 SP ) ADD NEXT END-CODE CODE DNEGATE (S d# -- d#' ) LONG SP ) NEG NEXT END-CODE CODE S>D (S n -- d ) SP )+ A0 MOVE A0 SP -) LMOVE NEXT END-CODE CODE DABS (S d# -- d# ) SP ) TST 0< IF LONG SP ) NEG THEN NEXT END-CODE \ 32 bit Arithmetic Operations 06Jan86gemCODE D2* (S d -- d*2 ) LONG SP )+ D0 MOVE 1 # D0 ASL D0 SP -) MOVE NEXT END-CODE CODE D2/ (S d -- d/2 ) LONG SP )+ D0 MOVE 1 # D0 ASR D0 SP -) MOVE NEXT END-CODE : D- (S d1 d2 -- d3 ) DNEGATE D+ ; : ?DNEGATE (S d1 n -- d2 ) 0< IF DNEGATE THEN ; \ 32 bit Comparison Operations 06Jan86gem: D0= (S d -- f ) OR 0= ; : D= (S d1 d2 -- f ) D- D0= ; : DU< (S ud1 ud2 -- f ) ROT SWAP 2DUP U< IF 2DROP 2DROP TRUE ELSE <> IF 2DROP FALSE ELSE U< THEN THEN ; : D< (S d1 d2 -- f ) 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; : D> (S d1 d2 -- f ) 2SWAP D< ; : DMIN (S d1 d2 -- d3 ) 4DUP D> IF 2SWAP THEN 2DROP ; : DMAX (S d1 d2 -- d3 ) 4DUP D< IF 2SWAP THEN 2DROP ; \ Mixed Mode Arithmetic 06Jan86gem: *D (S n1 n2 -- d# ) 2DUP XOR >R ABS SWAP ABS UM* R> ?DNEGATE ; : M/MOD (S d# n1 -- rem quot ) ?DUP IF DUP >R 2DUP XOR >R >R DABS R@ ABS UM/MOD SWAP R> ?NEGATE SWAP R> 0< IF NEGATE OVER IF 1- R@ ROT - SWAP THEN THEN R> DROP THEN ; : MU/MOD (S d# n1 -- rem d#quot ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ 16 bit multiply and divide 06Jan86gem: * (S n1 n2 -- n3 ) UM* DROP ; : /MOD (S n1 n2 -- rem quot ) >R S>D R> M/MOD ; : / (S n1 n2 -- quot ) /MOD NIP ; : MOD (S n1 n2 -- rem ) /MOD DROP ; : */MOD (S n1 n2 n3 -- rem quot ) >R *D R> M/MOD ; : */ (S n1 n2 n3 -- n1*n2/n3 ) */MOD NIP ; \ Task Dependant USER Variables 06Jan86gemUSER DEFINITIONS VARIABLE TOS ( TOP OF STACK ) VARIABLE ENTRY ( ENTRY POINT, CONTAINS MACHINE CODE ) VARIABLE LINK ( LINK TO NEXT TASK ) VARIABLE SP0 ( INITIAL PARAMETER STACK ) VARIABLE RP0 ( INITIAL RETURN STACK ) VARIABLE DP ( DICTIONARY POINTER ) VARIABLE #OUT ( NUMBER OF CHARACTERS EMITTED ) VARIABLE #LINE ( THE NUMBER OF LINES SENT SO FAR ) VARIABLE OFFSET ( RELATIVE TO ABSOLUTE DISK BLOCK 0 ) VARIABLE BASE ( FOR NUMERIC INPUT AND OUTPUT ) VARIABLE HLD ( POINTS TO LAST CHARACTER HELD IN PAD ) VARIABLE FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE IN-FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE PRINTING \ System VARIABLEs 06Jan86gemDEFER EMIT ( TO ALLOW PRINT SPOOLING ) META DEFINITIONS VARIABLE SCR ( SCREEN LAST LISTED OR EDITED ) VARIABLE PRIOR ( USED FOR DICTIONARY SEARCHES ) VARIABLE STATE ( COMPILATION OR INTERPRETATION ) VARIABLE WARNING ( GIVE USER DUPLICATE WARNINGS IF ON ) VARIABLE DPL ( NUMERIC INPUT PUNCTUATION ) VARIABLE R# ( EDITING CURSOR POSITION ) VARIABLE LAST ( POINTS TO NFA OF LATEST DEFINITION ) VARIABLE CSP ( HOLDS STACK POINTER FOR ERROR CHECKING ) VARIABLE CURRENT ( VOCABULARY WHICH GETS DEFINITIONS ) 8 CONSTANT #VOCS ( THE NUMBER OF VOCABULARIES TO SEARCH ) VARIABLE CONTEXT ( VOCABULARY SEARCHED FIRST ) HERE THERE #VOCS 2* DUP ALLOT ERASE \ System Variables 06Jan86gemVARIABLE 'TIB ( ADDRESS OF TERMINAL INPUT BUFFER ) VARIABLE WIDTH ( WIDTH OF NAME FIELD ) VARIABLE VOC-LINK ( POINTS TO NEWEST VOCABULARY ) VARIABLE BLK ( BLOCK NUMBER TO INTERPRET ) VARIABLE >IN ( OFFSET INTO INPUT STREAM ) VARIABLE SPAN ( NUMBER OF CHARACTERS EXPECTED ) VARIABLE #TIB ( NUMBER OF CHARACTERS TO INTERPRET ) VARIABLE END? ( TRUE IF INPUT STREAM EXHAUSTED ) \ Devices Strings 06Jan86gem 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL VARIABLE CAPS CODE FILL ( start-addr count char -- ) SP )+ D0 MOVE SP )+ D1 MOVE SP )+ D7 MOVE D7 A0 LMOVE 1 D1 SUBQ D1 DO BYTE D0 A0 )+ MOVE LOOP NEXT END-CODE : ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; CODE COUNT (S addr -- addr+1 len ) SP )+ D7 MOVE D7 A0 LMOVE D0 CLR BYTE A0 )+ D0 MOVE WORD A0 SP -) MOVE D0 SP -) MOVE NEXT END-CODE CODE LENGTH (S addr -- addr+2 len ) SP )+ D7 MOVE D7 A0 LMOVE A0 )+ D0 MOVE A0 SP -) MOVE D0 SP -) MOVE NEXT END-CODE : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; \ Devices Strings 06Jan86gemCODE UPC (S char -- upper-case-char ) SP )+ D6 MOVE BYTE ASCII a D6 CMPI >= IF ASCII z D6 CMPI <= IF BL D6 SUBI THEN THEN WORD D6 SP -) MOVE NEXT END-CODE : UPPER (S addr len -- ) BOUNDS ?DO I DUP C@ UPC SWAP C! LOOP ; : HERE (S -- addr ) DP @ ; : PAD (S -- addr ) HERE 80 + ; : -TRAILING (S addr len -- addr len' ) DUP 0 ?DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; \ Devices Strings 06Jan86gemCODE COMP (S addr1 addr2 len -- -1 | 0 | 1 ) SP )+ D0 MOVE 1 D0 ADDQ SP )+ D7 MOVE D7 A0 LMOVE SP )+ D7 MOVE D7 A1 LMOVE BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 )+ A0 )+ CMPM WORD 0<> IF 0< IF 1 # SP -) MOVE ELSE -1 # SP -) MOVE THEN NEXT THEN REPEAT SP -) CLR NEXT END-CODE \ Devices Strings 26Jun86gemLABEL >UPPER ( D6 --> D6 ) BYTE ASCII a D6 CMPI >= IF ASCII z D6 CMPI <= IF BL D6 SUBI THEN THEN RTS CODE CAPS-COMP (S addr1 addr2 len -- -1 | 0 | 1 ) SP )+ D0 MOVE 1 D0 ADDQ SP )+ D7 MOVE D7 A0 LMOVE SP )+ D7 MOVE D7 A1 LMOVE BEGIN 1 D0 SUBQ 0<> WHILE BYTE A1 )+ D6 MOVE >UPPER bank L#) JSR D6 D1 MOVE A0 )+ D6 MOVE >UPPER bank L#) JSR D1 D6 CMP WORD 0<> IF 0< IF 1 # SP -) MOVE ELSE -1 # SP -) MOVE THEN NEXT THEN REPEAT SP -) CLR NEXT END-CODE : COMPARE (S addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; \ Devices Terminal IO via CP/M BIOS 25Jun86gemCREATE REG-BUF 64 ALLOT ( Save registers ) CODE TRAP#1 (S n...n fun -- n...n fun d0.l ) 1 TRAP D0 SP -) LMOVE NEXT END-CODE CODE TRAP#13 (S n...n fun -- n...n fun d0.l ) 13 TRAP D0 SP -) LMOVE NEXT END-CODE CODE TRAP#14 (S n...n fun -- n...n fun d0.l ) 14 TRAP D0 SP -) LMOVE NEXT END-CODE : (KEY?) (S -- f ) 11 TRAP#1 DROP NIP 0<> ; : (KEY) (S -- char ) BEGIN PAUSE (KEY?) UNTIL 7 TRAP#1 DROP NIP ; : (CONSOLE) (S char -- ) PAUSE 6 TRAP#1 2DROP 2DROP 1 #OUT +! ; \ Devices Terminal Input and Output 19Jun86gemDEFER KEY? DEFER KEY DEFER CR : PR-STAT (S -- f ) 17 TRAP#1 DROP NIP 0<> ; : (PRINT) (S char -- ) BEGIN PAUSE PR-STAT UNTIL 5 TRAP#1 2DROP 1 #OUT +! ; : (EMIT) (S char -- ) PRINTING @ IF DUP (PRINT) -1 #OUT +! THEN (CONSOLE) ; : CRLF (S -- ) 13 EMIT 10 EMIT #OUT OFF 1 #LINE +! ; : TYPE (S addr len -- ) 0 ?DO COUNT EMIT LOOP DROP ; : SPACE (S -- ) BL EMIT ; : SPACES (S n -- ) 0 MAX 0 ?DO SPACE LOOP ; : BACKSPACES (S n -- ) 0 ?DO BS EMIT LOOP ; : BEEP (S -- ) BELL EMIT ; \ Devices System Dependent Control Characters 06Jan86gem: BS-IN (S n c -- 0 | n-1 ) DROP DUP IF 1- BS ELSE BELL THEN EMIT ; : (DEL-IN) (S n c -- 0 | n-1 ) DROP DUP IF 1- BS EMIT SPACE BS ELSE BELL THEN EMIT ; : BACK-UP (S n c -- 0 ) DROP DUP BACKSPACES DUP SPACES BACKSPACES 0 ; : RES-IN (S c -- ) FORTH TRUE ABORT" Reset" ; : P-IN (S c -- ) DROP PRINTING @ NOT PRINTING ! ; \ Devices Terminal Input 06Jan86gem: CR-IN (S m a n c -- m a m ) DROP SPAN ! OVER BL EMIT ; : (CHAR) (S a n char -- a n+1 ) 3DUP EMIT + C! 1+ ; DEFER CHAR DEFER DEL-IN VARIABLE CC CREATE CC-FORTH ] CHAR CHAR CHAR RES-IN CHAR CHAR CHAR CHAR BS-IN CHAR CHAR CHAR CHAR CR-IN CHAR CHAR P-IN CHAR CHAR CHAR CHAR BACK-UP CHAR CHAR BACK-UP CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ Devices Terminal Input 06Jan86gem: EXPECT (S adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP 2* CC @ + PERFORM ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN THEN REPEAT 2DROP DROP ; : TIB (S -- adr ) 'TIB @ ; : QUERY (S -- ) TIB 80 EXPECT SPAN @ #TIB ! BLK OFF >IN OFF ; \ Devices BLOCK I/O 19Jun86gem 4 CONSTANT #BUFFERS 1024 CONSTANT B/BUF 1024 CONSTANT B/REC 1 CONSTANT REC/BLK 44 CONSTANT B/FCB VARIABLE DISK-ERROR -2 CONSTANT LIMIT #BUFFERS 1+ 8 * 2+ CONSTANT >SIZE LIMIT B/BUF #BUFFERS * - CONSTANT FIRST FIRST >SIZE - CONSTANT INIT-R0 : >BUFFERS (S -- adr ) FIRST >SIZE - ; : >END (S -- adr ) FIRST 2- ; : BUFFER# (S n -- adr ) 8* >BUFFERS + ; : >UPDATE (S -- adr ) 1 BUFFER# 6 + ; \ Devices BLOCK I/O 19Jun86gemDEFER READ-BLOCK (S buffer-header -- ) DEFER WRITE-BLOCK (S buffer-header -- ) : .FILE (S adr -- ) BEGIN DUP C@ DUP 0<> WHILE EMIT 1+ REPEAT 2DROP ; : FILE? (S -- ) FILE @ .FILE ; : SWITCH (S -- ) FILE @ IN-FILE @ FILE ! IN-FILE ! ; VOCABULARY DOS DOS DEFINITIONS : !FILES (S fcb -- ) DUP FILE ! IN-FILE ! ; : DISK-ABORT (S fcb a n -- ) TYPE ." in " .FILE ABORT ; : ?DISK-ERROR (S fcb n -- ) DUP DISK-ERROR ! IF " Disk error" DISK-ABORT ELSE DROP THEN ; \ Devices BLOCK I/O 24Jun86gem CREATE DMA B/FCB ALLOT CREATE FCB1 B/FCB ALLOT : CLR-FCB (S fcb -- ) B/FCB ERASE ; : CLR-DMA (S dma -- ) B/FCB ERASE ; \ 16 bit adr only : SET-DMA (S daddr -- ) 26 TRAP#1 2DROP DROP 2DROP ; : HANDLE# (S fcb -- adr ) 30 + ; : RECORD# (S fcb -- adr ) 34 + ; : MAXREC# (S fcb -- adr ) 38 + ; : IN-RANGE (S fcb -- fcb ) DUP MAXREC# @ OVER RECORD# @ U< DUP DISK-ERROR ! IF 1 BUFFER# ON " Out of Range" DISK-ABORT THEN ; \ Devices BLOCK I/O 26Jun86gem: SET-IO (S buffer-header -- buffer-header ) DUP 2@ SWAP RECORD# ! DUP 2@ DROP IN-RANGE DROP ; : FILE-READ (S buffer-header -- ) SET-IO DUP 2@ SWAP HANDLE# @ SWAP 0 ( from beginning ) -ROT B/BUF *D 66 TRAP#1 2DROP DROP 2DROP 2DROP ( clean stack ) 2+ 2@ bank SWAP B/BUF SWAP 0 SWAP HANDLE# @ 63 TRAP#1 2DROP 2DROP 2DROP 2DROP ; : FILE-WRITE (S buffer-header -- ) SET-IO DUP 2@ SWAP HANDLE# @ SWAP 0 ( from beginning ) -ROT B/BUF *D 66 TRAP#1 2DROP DROP 2DROP 2DROP ( clean stack ) 2+ 2@ bank SWAP B/BUF SWAP 0 SWAP HANDLE# @ 64 TRAP#1 2DROP 2DROP 2DROP 2DROP ; : FILE-IO (S -- ) ['] FILE-READ IS READ-BLOCK ['] FILE-WRITE IS WRITE-BLOCK ; \ Devices BLOCK I/O 19Jun86gemFORTH DEFINITIONS : CAPACITY (S -- n ) [ DOS ] FILE @ MAXREC# @ 1+ ; : LATEST? (S n fcb -- fcb n | a f ) DISK-ERROR OFF SWAP OFFSET @ + 2DUP 1 BUFFER# 2@ D= IF 2DROP 1 BUFFER# 4 + @ FALSE R> DROP THEN ; : ABSENT? (S n fcb -- a f ) LATEST? FALSE #BUFFERS 1+ 2 DO DROP 2DUP I BUFFER# 2@ D= IF 2DROP I LEAVE ELSE FALSE THEN LOOP ?DUP IF BUFFER# DUP >BUFFERS 8 CMOVE >R >BUFFERS DUP 8 + OVER R> SWAP - CMOVE> 1 BUFFER# 4 + @ FALSE ELSE >BUFFERS 2! TRUE THEN ; \ Devices BLOCK I/O 06Jan86gem: UPDATE (S -- ) >UPDATE ON ; : DISCARD (S -- ) 1 >UPDATE ! ( 1 BUFFER# ON ) ; : MISSING (S -- ) >END 2- @ 0< IF >END 2- OFF >END 8 - WRITE-BLOCK THEN >END 4 - @ >BUFFERS 4 + ! ( buffer ) 1 >BUFFERS 6 + ! >BUFFERS DUP 8 + #BUFFERS 8* CMOVE> ; : (BUFFER) (S n fcb -- a ) PAUSE ABSENT? IF MISSING 1 BUFFER# 4 + @ THEN ; : BUFFER (S n -- a ) FILE @ (BUFFER) ; : (BLOCK) (S n fcb -- a ) (BUFFER) >UPDATE @ 0> IF 1 BUFFER# DUP READ-BLOCK 6 + OFF THEN ; : BLOCK (S n -- a ) FILE @ (BLOCK) ; : IN-BLOCK (S n -- a ) IN-FILE @ (BLOCK) ; \ Devices BLOCK I/O 06Jan86gem: EMPTY-BUFFERS (S -- ) FIRST LIMIT OVER - ERASE >BUFFERS #BUFFERS 1+ 8* ERASE FIRST 1 BUFFER# #BUFFERS 0 DO DUP ON 4 + 2DUP ! SWAP B/BUF + SWAP 4 + LOOP 2DROP ; : SAVE-BUFFERS (S -- ) 1 BUFFER# #BUFFERS 0 DO DUP @ 1+ IF DUP 6 + @ 0< IF DUP WRITE-BLOCK DUP 6 + OFF THEN 8 + THEN LOOP DROP ; : FLUSH (S -- ) SAVE-BUFFERS 0 BLOCK DROP EMPTY-BUFFERS ; : VIEW# (S -- addr ) FILE @ 40 + ; \ Devices BLOCK I/O 26Jun86gemDOS DEFINITIONS : FILE-SIZE (S fcb -- n ) DMA bank SET-DMA 0 ( normal ) OVER bank 78 TRAP#1 2DROP 2DROP 2DROP DMA 26 + 2@ B/BUF M/MOD NIP 1- DUP ROT MAXREC# ! ; : DOS-ERR? (S -- f ) 0< ; : OPEN-FILE (S -- ) 2 ( read & write ) IN-FILE @ bank 61 TRAP#1 DROP >R 2DROP 2DROP R> DUP DOS-ERR? IF DISK-ERROR ! IN-FILE @ " Open error" DISK-ABORT THEN IN-FILE @ HANDLE# ! IN-FILE @ FILE-SIZE DROP ; \ Devices BLOCK I/O * 26Jun86gem\ HEX 45C CONSTANT DOS-FCB DECIMAL FORTH DEFINITIONS \ : DEFAULT (S -- ) [ DOS ] FCB1 DUP IN-FILE ! DUP FILE ! \ CLR-FCB DOS-FCB 1+ C@ BL <> \ IF DOS-FCB FCB1 12 CMOVE OPEN-FILE THEN ; : EXTEND (S -- ) [ DOS ] FCB1 CLR-FCB " EXTEND.BLK" FCB1 SWAP CMOVE FCB1 DUP IN-FILE ! FILE ! OPEN-FILE ; : (LOAD) (S n -- ) FILE @ >R BLK @ >R >IN @ >R >IN OFF BLK ! IN-FILE @ FILE ! RUN R> >IN ! R> BLK ! R> !FILES ; DEFER LOAD \ Interactive Layer Number Input 06Jan86gemASSEMBLER LABEL FAIL SP -) CLR NEXT CODE DIGIT (S char base -- n true | char false ) SP )+ D0 MOVE SP ) D1 MOVE BYTE 48 # D1 SUB FAIL BMI 10 # D1 CMP 0>= IF 17 # D1 CMP FAIL BMI 7 D1 SUBQ THEN D0 D1 CMP FAIL BPL WORD D1 SP ) MOVE TRUE # SP -) MOVE NEXT END-CODE : DOUBLE? (S -- f ) DPL @ 1+ 0<> ; : CONVERT (S +d1 adr1 -- +d2 adr2 ) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DOUBLE? IF 1 DPL +! THEN R> REPEAT DROP R> ; \ Interactive Layer Number Input 06Jan86gem: (NUMBER?) (S adr -- d flag ) 0 0 ROT DUP 1+ C@ ASCII - = DUP >R - -1 DPL ! BEGIN CONVERT DUP C@ ASCII , ASCII / BETWEEN WHILE 0 DPL ! REPEAT -ROT R> IF DNEGATE THEN ROT C@ BL = ; : NUMBER? (S adr -- d flag ) FALSE OVER COUNT BOUNDS ?DO I C@ BASE @ DIGIT NIP IF DROP TRUE LEAVE THEN LOOP IF (NUMBER?) ELSE DROP 0 0 FALSE THEN ; : (NUMBER) (S adr -- d# ) NUMBER? NOT ?MISSING ; DEFER NUMBER \ Interactive Layer Number Output 20Jun86gem: HOLD (S char -- ) -1 HLD +! HLD @ C! ; : <# (S -- ) PAD HLD ! ; : #> (S d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN (S n1 -- ) 0< IF ASCII - HOLD THEN ; : # (S -- ) BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; : #S (S -- ) BEGIN # 2DUP OR 0= UNTIL ; : HEX (S -- ) 16 BASE ! ; : DECIMAL (S -- ) 10 BASE ! ; : OCTAL (S -- ) 8 BASE ! ; : BINARY (S -- ) 2 BASE ! ; \ Interactive Layer Number Output 06Jan86gem: (U.) (S u -- a l ) 0 <# #S #> ; : U. (S u -- ) (U.) TYPE SPACE ; : U.R (S u l -- ) >R (U.) R> OVER - SPACES TYPE ; : (.) (S n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; : . (S n -- ) (.) TYPE SPACE ; : .R (S n l -- ) >R (.) R> OVER - SPACES TYPE ; : (UD.) (S ud -- a l ) <# #S #> ; : UD. (S ud -- ) (UD.) TYPE SPACE ; : UD.R (S ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; : (D.) (S d -- a l ) TUCK DABS <# #S ROT SIGN #> ; : D. (S d -- ) (D.) TYPE SPACE ; : D.R (S d l -- ) >R (D.) R> OVER - SPACES TYPE ; \ SKIP SCAN 06Jan86gemASSEMBLER LABEL DONE A0 SP -) MOVE D1 SP -) MOVE NEXT END-CODE CODE SKIP (S adr1 len1 char -- adr2 len2 ) SP )+ D0 MOVE SP )+ D1 MOVE 1 D1 ADDQ SP )+ D7 MOVE D7 A0 LMOVE BEGIN 1 D1 SUBQ 0<> WHILE BYTE A0 ) D2 MOVE D2 D0 CMP DONE BNE WORD 1 A0 ADDQ REPEAT DONE BRA END-CODE CODE SCAN (S adr1 len1 char -- adr2 len2 ) SP )+ D0 MOVE SP )+ D1 MOVE 1 D1 ADDQ SP )+ D7 MOVE D7 A0 LMOVE BEGIN 1 D1 SUBQ 0<> WHILE BYTE A0 ) D2 MOVE D2 D0 CMP DONE BEQ WORD 1 A0 ADDQ REPEAT DONE BRA END-CODE \ Interactive Layer Parsing 06Jan86gem: /STRING (S addr len n -- addr' len' ) OVER MIN ROT OVER + -ROT - ; : PLACE (S str-addr len to -- ) 3DUP 1+ SWAP MOVE C! DROP ; : (SOURCE) (S -- addr len ) BLK @ ?DUP IF BLOCK B/BUF ELSE TIB #TIB @ THEN ; DEFER SOURCE : PARSE-WORD (S char -- addr len ) >R SOURCE TUCK >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R OVER - ROT R> DUP 0<> + - >IN ! ; : PARSE (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; \ Interactive Layer Parsing 06Jan86gem: 'WORD (S -- adr ) HERE ; : WORD (S char -- addr ) PARSE-WORD 'WORD PLACE 'WORD DUP COUNT + BL SWAP C! ( Stick Blank at end ) ; : >TYPE (S adr len -- ) TUCK PAD SWAP CMOVE PAD SWAP TYPE ; : .( (S -- ) ASCII ) PARSE >TYPE ; IMMEDIATE : ( (S -- ) ASCII ) PARSE 2DROP ; IMMEDIATE : \S (S -- ) END? ON ; IMMEDIATE \ Interactive Layer Dictionary 26Jun86gemCODE TRAVERSE (S addr direction -- addr' ) SP )+ D0 MOVE SP )+ D7 MOVE D7 A0 LMOVE D0 A0 ADDA BEGIN A0 ) 7 # BTST 0= WHILE D0 A0 ADDA REPEAT A0 SP -) MOVE NEXT END-CODE : DONE? (S n -- f ) STATE @ <> END? @ OR END? OFF ; : FORTH-83 (S -- ) FORTH DEFINITIONS CAPS OFF ." (almost) " ; \ Interactive Layer Dictionary 06Jan86gem: N>LINK 2- ; : L>NAME 2+ ; : BODY> 2- ; : NAME> 1 TRAVERSE 1+ ; : LINK> L>NAME NAME> ; : >BODY 2+ ; : >NAME 1- -1 TRAVERSE ; : >LINK >NAME N>LINK ; : >VIEW >LINK 2- ; : VIEW> 2+ LINK> ; CODE HASH (S str-addr voc-ptr -- thread ) SP )+ D1 MOVE SP )+ D7 MOVE D7 A0 LMOVE BYTE A0 )+ TST A0 )+ D0 MOVE WORD 3 # D0 AND D0 D0 ADD D0 D1 ADD D1 SP -) MOVE NEXT END-CODE \ Interactive Layer Dictionary 06Jan86gemCODE (FIND) (S string link -- code true | adr false ) HEX D7 D6 LMOVE D2 CLR SP )+ D7 MOVE BEGIN 0<> WHILE D7 A1 LMOVE SP ) D6 MOVE D6 A0 LMOVE A1 )+ TST BYTE A0 )+ D0 MOVE A1 )+ D1 MOVE D1 D2 MOVE D0 D1 EOR 3F # D1 AND ( mask flag bits ) 0= IF BEGIN A0 )+ D0 MOVE A1 )+ D1 MOVE D0 D1 EOR 0<> UNTIL 7F # D1 AND 0= ( found? ) WORD IF A1 SP ) MOVE 40 # D2 AND 0<> IF 1 # SP -) MOVE ELSE -1 # SP -) MOVE THEN NEXT THEN THEN D7 A1 LMOVE A1 ) D7 MOVE REPEAT SP -) CLR NEXT END-CODE DECIMAL \ Interactive Layer Dictionary 06Jan86gem4 CONSTANT #THREADS : FIND (S addr -- cfa flag | addr false ) DUP C@ IF PRIOR OFF FALSE #VOCS 0 DO DROP CONTEXT I 2* + @ DUP IF DUP PRIOR @ OVER PRIOR ! = IF DROP FALSE ELSE OVER SWAP HASH @ (FIND) DUP ?LEAVE THEN THEN LOOP ELSE DROP END? ON ['] NOOP 1 THEN ; : ?UPPERCASE (S adr -- adr ) CAPS @ IF DUP COUNT UPPER THEN ; : DEFINED (S -- here 0 | cfa [ -1 | 1 ] ) BL WORD ?UPPERCASE FIND ; \ Interactive Layer Interpreter 06Jan86gem: ?STACK (S -- ) ( System dependant ) SP@ SP0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; DEFER STATUS (S -- ) : INTERPRET (S -- ) BEGIN ?STACK DEFINED IF EXECUTE ELSE NUMBER DOUBLE? NOT IF DROP THEN THEN FALSE DONE? UNTIL ; \ Extensible Layer Compiler 06Jan86gem: ALLOT (S n -- ) DP +! ; : , (S n -- ) HERE ! 2 ALLOT ; : C, (S char -- ) HERE C! 1 ALLOT ; : ALIGN HERE 1 AND IF BL C, THEN ; : EVEN DUP 1 AND + ; : COMPILE (S -- ) R> DUP 2+ >R @ , ; : IMMEDIATE (S -- ) 64 ( Precedence bit ) LAST @ CSET ; : LITERAL (S n -- ) COMPILE (LIT) , ; IMMEDIATE : DLITERAL (S d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII (S -- n ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : CONTROL (S -- n ) BL WORD 1+ C@ 31 AND STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE \ Extensible Layer Compiler 06Jan86gem: CRASH (S -- ) TRUE ABORT" Uninitialized execution vector." ; : ?MISSING (S f -- ) IF 'WORD COUNT TYPE TRUE ABORT" ?" THEN ; : ' (S -- cfa ) DEFINED 0= ?MISSING ; : ['] (S -- ) ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] (S -- ) ' , ; IMMEDIATE : (") (S -- addr len ) R> COUNT 2DUP + EVEN >R ; : (.") (S -- ) R> COUNT 2DUP + EVEN >R TYPE ; : ," (S -- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ALIGN ; : ." (S -- ) COMPILE (.") ," ; IMMEDIATE : " (S -- ) COMPILE (") ," ; IMMEDIATE \ Interactive Layer Dictionary 06Jan86gemVARIABLE FENCE : TRIM (S faddr voc-addr -- ) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE @ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FORGET) (S addr -- ) DUP FENCE @ U< ABORT" Below fence" DUP VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! NIP BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DROP DP ! ; : FORGET (S -- ) BL WORD ?UPPERCASE DUP CURRENT @ HASH @ (FIND) 0= ?MISSING >VIEW (FORGET) ; \ Extensible Layer Compiler 06Jan86gemDEFER WHERE DEFER ?ERROR : (?ERROR) (S adr len f -- ) IF >R >R SP0 @ SP! PRINTING OFF BLK @ IF >IN @ BLK @ WHERE THEN R> R> SPACE TYPE SPACE QUIT ELSE 2DROP THEN ; : (ABORT") (S f -- ) R@ COUNT ROT ?ERROR R> COUNT + EVEN >R ; : ABORT" (S -- ) COMPILE (ABORT") ," ; IMMEDIATE : ABORT (S -- ) TRUE ABORT" " ; \ Extensible Layer Structures 06Jan86gem: ?CONDITION (S f -- ) NOT ABORT" Conditionals Wrong" ; : >MARK (S -- addr ) HERE 0 , ; : >RESOLVE (S addr -- ) HERE SWAP ! ; : <MARK (S -- addr ) HERE ; : <RESOLVE (S addr -- ) , ; : ?>MARK (S -- f addr ) TRUE >MARK ; : ?>RESOLVE (S f addr -- ) SWAP ?CONDITION >RESOLVE ; : ?<MARK (S -- f addr ) TRUE <MARK ; : ?<RESOLVE (S f addr -- ) SWAP ?CONDITION <RESOLVE ; : LEAVE COMPILE (LEAVE) ; IMMEDIATE : ?LEAVE COMPILE (?LEAVE) ; IMMEDIATE \ Extensible Layer Structures 06Jan86gem: BEGIN ?<MARK ; IMMEDIATE : THEN ?>RESOLVE ; IMMEDIATE : DO COMPILE (DO) ?>MARK ; IMMEDIATE : ?DO COMPILE (?DO) ?>MARK ; IMMEDIATE : LOOP COMPILE (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : +LOOP COMPILE (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE ; IMMEDIATE : UNTIL COMPILE ?BRANCH ?<RESOLVE ; IMMEDIATE : AGAIN COMPILE BRANCH ?<RESOLVE ; IMMEDIATE : REPEAT 2SWAP [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE : IF COMPILE ?BRANCH ?>MARK ; IMMEDIATE : ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE : WHILE [COMPILE] IF ; IMMEDIATE \ Extensible Layer Defining Words 06Jan86gem: ,VIEW (S -- ) BLK @ DUP IF VIEW# @ 4096 * + THEN , ; : "CREATE (S str -- ) COUNT HERE EVEN 4 + PLACE ALIGN ,VIEW HERE 0 , ( reserve link ) HERE LAST ! ( remember nfa ) HERE ( lfa nfa ) WARNING @ IF FIND IF HERE COUNT TYPE ." isn't unique " THEN DROP HERE THEN ( lfa nfa ) CURRENT @ HASH DUP @ ( lfa tha prev ) HERE 2- ROT ! ( lfa prev ) SWAP ! ( Resolve link field) HERE DUP C@ WIDTH @ MIN 1+ ALLOT ALIGN 128 SWAP CSET 128 HERE 1- CSET ( delimiter Bits ) COMPILE [ [FORTH] ASSEMBLER DOCREATE , META ] ; : CREATE (S -- ) BL WORD ?UPPERCASE "CREATE ; \ Extensible Layer Defining Words 26Jun86gem: !CSP (S -- ) SP@ CSP ! ; : ?CSP (S -- ) SP@ CSP @ <> ABORT" Stack Changed" ; : HIDE (S -- ) LAST @ DUP N>LINK @ SWAP CURRENT @ HASH ! ; : REVEAL (S -- ) LAST @ DUP N>LINK SWAP CURRENT @ HASH ! ; : (;USES) (S -- ) R> @ LAST @ NAME> ! ; VOCABULARY ASSEMBLER : ;USES (S -- ) ?CSP COMPILE (;USES) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : (;CODE) (S -- ) R> LAST @ NAME> ! ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE HEX : DOES> (S -- ) COMPILE (;CODE) 4EB9 , ( JSR.L ) [ DECIMAL ] [ [ASSEMBLER] DODOES META ] bank , LITERAL , ; IMMEDIATE \ Extensible Layer Defining Words 06Jan86gem: [ (S -- ) STATE OFF ; IMMEDIATE : ] (S -- ) STATE ON BEGIN ?STACK DEFINED DUP IF 0> IF EXECUTE ELSE , THEN ELSE DROP NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN TRUE DONE? UNTIL ; : : (S -- ) !CSP CURRENT @ CONTEXT ! CREATE HIDE ] ;USES NEST , : ; (S -- ) ?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE \ Extensible Layer Defining Words 06Jan86gem: RECURSIVE (S -- ) REVEAL ; IMMEDIATE : CONSTANT (S n -- ) CREATE , ;USES DOCONSTANT , : VARIABLE (S -- ) CREATE 0 , ;USES DOCREATE , : DEFER (S -- ) CREATE ['] CRASH , ;USES DODEFER , DODEFER RESOLVES <DEFER> : VOCABULARY (S -- ) CREATE #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES <VOCABULARY> : DEFINITIONS (S -- ) CONTEXT @ CURRENT ! ; \ Extensible Layer Defining Words 06Jan86gem: 2CONSTANT CREATE , , (S d# -- ) DOES> 2@ ; (S -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT (S -- ) DOES> ; (S -- addr ) DROP VARIABLE AVOC : CODE (S -- ) CREATE HIDE HERE DUP 2- ! CONTEXT @ AVOC ! ASSEMBLER ; ASSEMBLER DEFINITIONS : END-CODE AVOC @ CONTEXT ! REVEAL ; FORTH DEFINITIONS META IN-META \ Extensible Layer Defining Words 06Jan86gemVARIABLE #USER VOCABULARY USER USER DEFINITIONS : ALLOT (S n -- ) #USER +! ; ' CREATE ( avoid recursion: leave address for , in CREATE ) : CREATE (S -- ) [ , ] #USER @ , ;USES DOUSER-VARIABLE , : VARIABLE (S -- ) CREATE 2 ALLOT ; : DEFER (S -- ) VARIABLE ;USES DOUSER-DEFER , FORTH DEFINITIONS META IN-META \ Extensible Layer ReDefining Words 06Jan86gem: >IS (S cfa -- data-address ) DUP @ DUP [ [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [ASSEMBLER] DOUSER-DEFER META ] LITERAL = SWAP DROP OR IF >BODY @ UP @ + ELSE >BODY THEN ; : (IS) (S cfa --- ) R@ @ >IS ! R> 2+ >R ; : IS (S cfa --- ) STATE @ IF COMPILE (IS) ELSE ' >IS ! THEN ; IMMEDIATE \ Initialization High Level 21Jun86gem: RUN (S -- ) STATE @ IF ] STATE @ NOT IF INTERPRET THEN ELSE INTERPRET THEN ; : QUIT (S -- ) SP0 @ 'TIB ! BLK OFF [COMPILE] [ BEGIN RP0 @ RP! STATUS QUERY RUN STATE @ NOT IF ." ok" THEN AGAIN ; DEFER BOOT : WARM (S -- ) TRUE ABORT" Warm Start" ; : COLD (S -- ) BOOT QUIT ; \ Initialization High Level 26Jun86gem1 CONSTANT INITIAL : OK (S -- ) INITIAL LOAD ; : START (S -- ) EMPTY-BUFFERS ; \ DEFAULT ; : BYE ( -- ) CR HERE 0 256 UM/MOD NIP 1+ DECIMAL U. ." Pages" 0 TRAP#1 ; \ Initialization Low Level 26Jun86gem [ASSEMBLER] bank ORIGIN 8 + !-T HERE ORIGIN 10 + !-T ( WARM ENTRY POINT ) ' WARM bank L#) W LEA W )+ D7 MOVE D7 A0 LMOVE A0 ) JMP bank ORIGIN 2 + !-T HERE ORIGIN 4 + !-T ( COLD ENTRY POINT ) INIT-R0 bank L#) RP LEA INIT-R0 256 - bank L#) SP LEA LONG 0 bank # D7 MOVE WORD ' COLD bank L#) W LEA W )+ D7 MOVE D7 A0 LMOVE A0 ) JMP \ Initialize User Variables 06Jan86gemHERE UP !-T ( SET UP USER AREA ) 0 , ( TOS ) 0 , ( ENTRY ) 0 , ( LINK ) INIT-R0 256 - , ( SP0 ) INIT-R0 , ( RP0 ) 0 , ( DP ) ( Must be patched later ) 0 , ( #OUT ) 0 , ( #LINE ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) 0 , ( FILE ) 0 , ( IN-FILE ) FALSE , ( PRINTING ) ' (EMIT) , ( EMIT ) \ Resident Tools 06Jan86gem: DEPTH (S -- n ) SP@ SP0 @ SWAP - 2/ ; : .S (S -- ) DEPTH ?DUP IF 0 DO DEPTH I - 1- PICK 7 U.R SPACE KEY? ?LEAVE LOOP ELSE ." Empty " THEN ; : .ID (S nfa -- ) DUP 1+ DUP C@ ROT C@ 31 AND 0 ?DO DUP 127 AND EMIT 128 AND IF ASCII _ 128 OR ELSE 1+ DUP C@ THEN LOOP 2DROP SPACE ; : DUMP (S addr len -- ) 0 DO CR DUP 6 .R SPACE 16 0 DO DUP C@ 3 .R 1+ LOOP 16 +LOOP DROP ; \ For Completeness 24Jun86gem: RECURSE (S -- ) LAST @ NAME> , ; IMMEDIATE \ Resolve Forward References 06Jan86gem ' (.") RESOLVES <(.")> ' (") RESOLVES <(")> ' (;CODE) RESOLVES <(;CODE)> ' (;USES) RESOLVES <(;USES)> ' (IS) RESOLVES <(IS)> ' (ABORT") RESOLVES <(ABORT")> [ASSEMBLER] DOCREATE META RESOLVES <VARIABLE> [ASSEMBLER] DOUSER-DEFER META RESOLVES <USER-DEFER> [ASSEMBLER] DOUSER-VARIABLE META RESOLVES <USER-VARIABLE> \ Resolve Forward References 06Jan86gem' SWAP RESOLVES SWAP ' DEFINITIONS RESOLVES DEFINITIONS ' + RESOLVES + ' OVER RESOLVES OVER ' [ RESOLVES [ ' 2+ RESOLVES 2+ ' 1+ RESOLVES 1+ ' 2* RESOLVES 2* ' 2DUP RESOLVES 2DUP ' ?MISSING RESOLVES ?MISSING ' RUN RESOLVES RUN ' ABORT RESOLVES ABORT ' QUIT RESOLVES QUIT \ Initialize DEFER words 06Jan86gem ' (LOAD) IS LOAD ' (KEY?) IS KEY? ' (KEY) IS KEY ' CRLF IS CR ' FILE-READ IS READ-BLOCK ' FILE-WRITE IS WRITE-BLOCK ' NOOP IS WHERE ' CR IS STATUS ' (SOURCE) IS SOURCE ' START IS BOOT ' (NUMBER) IS NUMBER ' (CHAR) IS CHAR ' (DEL-IN) IS DEL-IN ' (?ERROR) IS ?ERROR \ Initialize Variables 06Jan86gem' FORTH >BODY CURRENT !-T ' FORTH >BODY CONTEXT !-T ' CC-FORTH >BODY CC !-T HERE-T DP UP @-T + !-T ( INIT USER DP ) #USER-T @ #USER !-T ( INIT USER VAR COUNT ) TRUE CAPS !-T ( SET TO IGNORE CASE ) TRUE WARNING !-T ( SET TO ISSUE WARNINGS ) 31 WIDTH !-T ( 31 CHARACTER NAMES ) VOC-LINK-T @ VOC-LINK !-T ( INIT VOC-LINK )